home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / db.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  4.9 KB  |  130 lines
  1. ; Wb-tree File Based Associative String Data Base System.
  2. ; Copyright (c) 1991, 1992, 1993 Holland Mark Martin
  3. ;
  4. ;Permission to use, copy, modify, and distribute this software and its
  5. ;documentation for educational, research, and non-profit purposes and
  6. ;without fee is hereby granted, provided that the above copyright
  7. ;notice appear in all copies and that both that copyright notice and
  8. ;this permission notice appear in supporting documentation, and that
  9. ;the name of Holland Mark Martin not be used in advertising or
  10. ;publicity pertaining to distribution of the software without specific,
  11. ;written prior consent in each case.  Permission to incorporate this
  12. ;software into commercial products can be obtained from Jonathan
  13. ;Finger, Holland Mark Martin, 174 Middlesex Turnpike, Burlington, MA,
  14. ;01803-4467, USA.  Holland Mark Martin makes no representations about
  15. ;the suitability or correctness of this software for any purpose.  It
  16. ;is provided "as is" without express or implied warranty.  Holland Mark
  17. ;Martin is under no obligation to provide any services, by way of
  18. ;maintenance, update, or otherwise.
  19.  
  20. (require (in-vicinity (program-vicinity) "sys"))
  21.  
  22. ;;; DEBUG AND TEST CODE
  23.  
  24. (define (create-bt seg typ wcb)
  25.   (let* ((a-han (make-han))
  26.      (ans (bt-create seg typ a-han wcb)))
  27.     (if (err? ans) ans a-han)))
  28.  
  29. (define (open-bt seg blknum wcb)
  30.   (let* ((a-han (make-han))
  31.      (ans (bt-open seg blknum a-han wcb)))
  32.     (if (err? ans) ans a-han)))
  33.  
  34. (define (close-bt! han)
  35.   (bt-close han))
  36.  
  37. ;;; rem! removes key-str and value.  returns #t if found, #f if not.
  38. (define (bt:rem! han key-str)
  39.   (bt-rem han key-str (string-length key-str) #f))
  40.  
  41. (define (bt:rem* han key-str key2-str)
  42.   (define tmpstr (make-string 256))
  43.   (substring-move! key-str 0 (string-length key-str) tmpstr 0)
  44.   (bt-rem-range han tmpstr (if (zero? (string-length key-str))
  45.                    START-OF-CHAIN (string-length key-str))
  46.         key2-str (if (zero? (string-length key2-str))
  47.                  END-OF-CHAIN (string-length key2-str))))
  48.  
  49. ;;; rem removes key-str and value.  returns value.
  50. (define (bt:rem han key-str)
  51.   (let* ((tmp-str (make-string 256))
  52.      (tlen (bt-rem han key-str (string-length key-str) tmp-str)))
  53.     (if (err? tlen) #f (substring tmp-str 0 tlen))))
  54.  
  55. ;;; put adds an key-str value pair to the database whose root is blk
  56. (define (bt:put! han key-str val-str)
  57.   (bt-put han key-str (string-length key-str) val-str (string-length val-str)))
  58.  
  59. ;;; get returns a string of the value or #f
  60. (define (bt:get han key)
  61.   (let* ((tmp-str (make-string 256))
  62.      (tlen (bt-get han key (string-length key) tmp-str)))
  63.     (if (err? tlen) #f (substring tmp-str 0 tlen))))
  64.  
  65. ;;; next returns a string of the next key-str or #f if at end.
  66. ;;; (bt:next blk #f) or (bt:next blk "") returns the first key-str.
  67. ;;; to make BLINK happy I'm passing length 0 instead of START-OF-CHAIN
  68.  
  69. (define (bt:next han key-str)
  70.   (let* ((tmp-str (make-string 256))
  71.      (tlen
  72.       (if (and key-str (> (string-length key-str) 0) )
  73.           (bt-next han key-str (string-length key-str) tmp-str)
  74.           (bt-next han "" START-OF-CHAIN tmp-str))))
  75.     (if (err? tlen) #f (substring tmp-str 0 tlen))))
  76.  
  77. ;;; prev returns a string of the previous key-str or #f if at end.
  78. ;;; (bt:prev blk #f) or (bt:prev blk "") returns the last key-str.
  79.  
  80. (define (bt:prev han key-str)
  81.   (let* ((tmp-str (make-string 256))
  82.      (tlen
  83.       (if (and key-str (> (string-length key-str) 0))
  84.           (bt-prev han key-str (string-length key-str) tmp-str)
  85.           (bt-prev han "" END-OF-CHAIN tmp-str))))
  86.     (if (err? tlen) #f (substring tmp-str 0 tlen))))
  87.  
  88. (define (create-db seg typ namestr)
  89.   (let* ((tmp-str (make-string 256))
  90.      (a-han (create-bt seg typ 0))
  91.      (d-han (open-bt seg 1 (+ WCB-SAP WCB-SAR))))
  92.     (if (or (err? a-han) (err? d-han)) #f
  93.      (begin
  94.       (long2str! tmp-str 1 (HAN-ID a-han))
  95.       (string-set! tmp-str 0 (integer->char 4))
  96.       (bt-put d-han namestr (string-length namestr) tmp-str 5)
  97.       (close-bt! d-han)
  98.       a-han))))
  99.  
  100. (define (open-db seg namestr)
  101.   (let* ((tmp-str (make-string 256))
  102.      (d-han (open-bt seg 1 (+ WCB-SAP WCB-SAR))))
  103.     (if (err? d-han) #f
  104.     (let* ((tlen (bt-get d-han namestr (string-length namestr) tmp-str)))
  105.       (close-bt! d-han)
  106.       (if (err? tlen) #f
  107.           (if (eqv? tlen 5)
  108.           (open-bt seg (str2long tmp-str 1) 0)
  109.           #f))))))
  110.  
  111. (define (bt:scan bthan op key1 key2 scmproc blklim)
  112.   (let ((ikey (make-string 256))
  113.     (respkt (make-vector pkt-size))
  114.     (proc
  115.      (and scmproc
  116.           (lambda (key klen val vlen extra)
  117.         (let ((res (scmproc (substring key 0 klen) (substring val 0 vlen))))
  118.           (cond ((number? res) res)
  119.             ((not res) NOTPRES)
  120.             ((boolean? res) SUCCESS)
  121.             ((not (string? res)) TYPERR)
  122.             ((substring-move! res 0 (string-length res) val 0)
  123.              (string-length res))))))))
  124.     (set-skey-count! respkt 0)
  125.     (set-skey-len! respkt (string-length key1))
  126.     (substring-move! key1 0 (string-length key1) ikey 0)
  127.     (let ((res (bt-scan bthan op ikey (skey-len respkt)
  128.             key2 (string-length key2) proc #f respkt blklim)))
  129.       (list res (skey-count respkt) (substring ikey 0 (skey-len respkt))))))
  130.